home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Mops 2.5 / Mops ƒ / Args next >
Encoding:
Text File  |  1994-10-03  |  6.9 KB  |  280 lines  |  [TEXT/MSET]
  1. \ Support for named parms and local variables
  2.  
  3.    24    constant    MAXPL        \ Should be enough!!
  4. false    value        LOCFLG        \ true = looking for local var tokens
  5.  
  6.  
  7. create    PARMLIST    maxPL cells  reserve
  8.  
  9.     0    value    SVHASH
  10. false    value    FLOAT?
  11.     0    value    PLentry_addr
  12.  
  13.  
  14. : INITLOCS        \ Initializes flags etc.
  15.     0 -> #PL  0 -> #P  0 -> #F
  16.     0 -> FltFlg  false -> locFlg  ;
  17.  
  18.  
  19. : FINDINPARMLIST        \ ( addr -- loc# T  OR  -- F )
  20.             \ loc# counts from right to left in the local/parm list.
  21.  
  22.     dup 1+ c@   & %  =  -> float?
  23.     hash -> svHash  false
  24.     #PL  0exit
  25.     ParmList  #PL 4*  bounds  DO
  26.         svHash  i @ =
  27.         IF  ( found )
  28.             drop  #PL
  29.             i parmlist -  4/
  30.             -  1-  true  LEAVE
  31.         THEN
  32.     4 +LOOP  ;
  33.  
  34.  
  35. : ADDTOPARMLIST        \ ( addr -- )  Adds an element to ParmList.
  36.                     \  addr points to a counted string.
  37.     findinParmList  ?error 95        \ Name not unique
  38.     #PL  maxPL  >=  ?error 110
  39.     FltFlg  1 <<   float? if  1 or  1 ++> #F  then  -> FltFlg
  40.     svHash
  41.     #PL  1 ++> #PL  4*  ParmList +  !  ;
  42.  
  43.  
  44. : FIRSTCHR
  45.     here 1+ c@  ;
  46.  
  47.  
  48. :f {
  49.     local? IF            \ local? already non-zero - this ought to mean we're
  50.                         \  in a local section
  51.         local? 0< ?error 92  -1 -> local?
  52.     THEN
  53.     initLocs
  54.     
  55.     BEGIN                    \ Loop to add parms/locals to parmlist
  56.         Mword drop
  57.         firstChr  & -  <>            \ look for --
  58.     WHILE
  59.         firstChr dup  & \  =  swap  & /  =  or
  60.                 \ Note: we allow / as an alternative to \
  61.  
  62.         IF        true -> locFlg
  63.         ELSE    firstChr  & } =  ?error 111
  64.             locFlg nif  1 ++> #P  then
  65.             here  AddToParmList
  66.         THEN
  67.     REPEAT
  68.     local? NIF                        \ In local sections, we do this at :LOC
  69.         here  -> PLentry_addr
  70.             \  If we have temp objects, we'll have to backup the DP and
  71.             \  recompile the entry sequence, since there'll be an extra local
  72.             \  (the frame pointer)
  73.         PLentry
  74.     THEN
  75.     & }  parse 2drop                \ eat characters until }
  76.     rest nip  0< ?error 112  ;f        \ Err if no final }
  77.  
  78.  
  79. \ FIND will call Pfind to attempt to find a name first.
  80. \ If Pfind finds the name is a local, it returns true and the
  81. \ cfa of LocParm, which is a dummy word whose handler compiles
  82. \ a local reference.
  83.  
  84. : PFIND        \ ( str-addr -- cfa T  |  -- str-addr F )
  85.     state
  86.     NIF        false
  87.     ELSE    dup  FindInParmList
  88.         IF                        \ Found
  89.             -> loc#  drop
  90.             float? IF  ['] FlocParm  ELSE  ['] locParm  THEN
  91.             true
  92.         ELSE    false            \ Not found
  93.         THEN
  94.     THEN   ;
  95.  
  96.  
  97. : ,EXEC        \ ( cfa n -- )
  98.     state
  99.     IF  (compN)  ELSE  exN  THEN  ;
  100.  
  101. \ Here are the different types that we can put prefixes on or send
  102. \ messages to:
  103.  
  104. TYPE{    notfnd  locTyp  flocTyp
  105.         tmpObjTyp  objTyp  ivarTyp  classTyp  superTyp
  106.         valTyp  fvalTyp  vecTyp  dynVecTyp  objptrTyp  wordTyp
  107.         regTyp  lbTyp  lbSelfTyp  bktTyp  }
  108.  
  109. \ notFnd    - not previously defined
  110. \ locTyp    - a local or named parm
  111. \ tmpObjTyp    - a temporary (local) object
  112. \ objTyp    - an object
  113. \ ivarTyp    - an ivar
  114. \ classTyp    - a class
  115. \ superTyp    - a named superclass specified by  msg: super> someClass
  116. \ valTyp    - a value
  117. \ FvalTyp    - a floating point value
  118. \ vecTyp    - a vector
  119. \ dynVecTyp    - a dynamic vector
  120. \ wordTyp    - an ordinary word
  121. \ regTyp    - a 680x0 register
  122. \ lbTyp        - ** or [] meaning late bind
  123. \ lbSelfTyp    - [self] meaning late bind to self
  124. \ BktTyp    - [ - Neon-compatible late bind
  125.  
  126. \ PRFTOKEN returns the type of a token for a prefix op.
  127.  
  128. \ First we need to make some handler codes available above the Nucleus.
  129.  
  130. : HDLR        \ ( cfa -- ha )
  131.     2- w@x  ;
  132.  
  133. ' key    hdlr    constant    VECTCODE
  134. ' base    hdlr    constant    VALCODE
  135. ' ^base    hdlr    constant    REGCODE
  136. ' hdlr    hdlr    constant    WORDCODE
  137.  
  138.     objPtr XX          ' xx  hdlr        forget xx
  139.                 constant    OBJPTRCODE
  140.     dynamicVect XX    ' xx  hdlr        forget xx
  141.                 constant    DYNVECTCODE
  142.  
  143. : PRFTOKEN    \ ( -- cfa type )
  144.     '  dup  ['] locParm  =  IF  locTyp    EXIT  THEN
  145.        dup  ['] FlocParm =  IF  FlocTyp    EXIT  THEN
  146.     dup  hdlr
  147.     CASE
  148.         valCode        OF    valTyp        ENDOF
  149.         FvalCode    OF    FvalTyp        ENDOF
  150.         vectCode    OF    vecTyp        ENDOF
  151.         dynVectCode    OF    dynVecTyp    ENDOF
  152.         regCode        OF    regTyp        ENDOF
  153.         objPtrCode    OF    objPtrTyp    ENDOF
  154.         ?error 114
  155.     ENDCASE  ;
  156.  
  157.  
  158. forward    ToObjPtr        \ Stores to an objPtr.  Defined in file Class.
  159.  
  160. : ->        immediate
  161.     PrfToken                \ All types are legal
  162.     objPtrTyp =  IF  toObjPtr  EXIT  THEN
  163.     $ 60  ( opcode for Store )  ,exec  ;
  164.                         \ NOTE: opcode for store hard coded here!!!
  165.  
  166. : CvrtFcode    \ ( code -- code' )
  167.     CASE
  168.         $ 21  OF  $ 41  ENDOF        \ +
  169.         $ 22  OF  $ 48  ENDOF        \ -
  170.         $ 28  OF  $ 55  ENDOF        \ Neg
  171.         ?error 114
  172.     ENDCASE  ;
  173.  
  174. : (+->)        \ ( code -- cfa code' )
  175.     PrfToken ( code cfa type )  rot swap ( cfa code type )
  176.     
  177.     CASE
  178.         locTyp        OF                ENDOF
  179.         FlocTyp        OF  CvrtFcode    ENDOF
  180.         valTyp        OF                ENDOF
  181.         FvalTyp        OF  CvrtFcode    ENDOF
  182.         regTyp        OF                ENDOF
  183.         ?error 114
  184.     ENDCASE  ;
  185.  
  186. : (FOP)
  187.     PrfToken  rot swap
  188.     CASE
  189.         locTyp        OF  ENDOF
  190.         FlocTyp        OF  ENDOF
  191.         FvalTyp        OF  ENDOF
  192.         ?error 114
  193.     ENDCASE  ;
  194.  
  195. \ Note: the following opcodes have to agree with the definitions in
  196. \ OD.asm.  I could have defined them as constants but this would have
  197. \ used up dictionary space for no great benefit.
  198.  
  199. : ++>    $ 21  (+->)  ,exec  ;        immediate
  200. : +>    postpone  ++>       ;        immediate        \ A synonym.
  201. : -->    $ 22  (+->)  ,exec  ;        immediate
  202. : AND>    $ 23  (+->)  ,exec  ;        immediate
  203. : OR>    $ 24  (+->)  ,exec  ;        immediate
  204. : XOR>    $ 25  (+->)  ,exec  ;        immediate
  205. : NEG>    $ 28  (+->)  ,exec  ;        immediate
  206. : NOT>    $ 29  (+->)  ,exec  ;        immediate
  207. : *>    $ 42  (fop)  ,exec  ;        immediate
  208. : />    $ 49  (fop)  ,exec  ;        immediate
  209. : ABS>    $ 54  (fop)  ,exec  ;        immediate
  210.  
  211. ' Pfind  -> Ufind
  212.  
  213. \         =========== Local sections ===========
  214.  
  215. forward        INITTEMPS
  216.  
  217. : ?LOC    local? 0=  ?error 91  ;            \ "We're not in a local section"
  218.  
  219. : LOCAL
  220.     local?  ?error 93  1 -> local?        \ We change it to the normal -1
  221.                                         \ as soon as "{" is read.
  222.     forward  ;
  223.  
  224.  
  225. : :LOC        immediate
  226.     local? 1 = IF  msg# 96  THEN        \ warning  - no locals defined
  227.     ?loc  304
  228.     here  '  (patch)  :noname            \ Like :F
  229.     #PL  IF  PLentry  THEN
  230.     frameSize IF  initTemps  THEN
  231.     false -> local?                \ We do this here so any EXITs
  232. ;                                \  tidy everything up properly
  233.  
  234.  
  235. : ;LOC        immediate
  236.     (;)  304 ?defn  ;        \ As local? is now false, everything else
  237.                             \ gets tidied up by (;)
  238.  
  239.  
  240. \            ============================================
  241.  
  242. : EVALUATE  { addr len \ x1 x2 x3 x4 -- ?? }
  243.  
  244.     save-input  drop            \ Must be 4
  245.     -> x4 -> x3 -> x2 -> x1        \ Move input-stream specs to locals
  246.  
  247.     addr -> src-start  len -> src-len  0 >in !  -1 -> source-id
  248.     echo?  IF  ." ***evaluating***  "  addr len type cr  THEN
  249.     interpret
  250.     x1 x2 x3 x4  4  restore-input  ?error 25  ;
  251.  
  252. \ We can EVALUATE strings which might have embedded returns, and we can't
  253. \ just convert returns to blanks since we want the comment operator \
  254. \ to only skip to the end of the line, not the end of the string.  We handle
  255. \ this by defining an immediate "word" which just consists of a return, which
  256. \ does nothing.  We initially define it as X then patch it.  Our dic
  257. \ threading scheme doesn't clobber this since we just hash on the length,
  258. \ which remains 1.
  259.  
  260. : X        ;  immediate
  261.  
  262. 13 ( cr )   ' x  >name 1+  c!
  263.  
  264.  
  265. : (COMPINL)    \ ( cfa -- )
  266.     2+ count  evaluate  ;
  267.  
  268. ' (compinl) -> compinline
  269.  
  270. : INLINE{        immediate
  271.     method? IF  -4 allot  THEN        \ Wipe out method entry sequence
  272.                                     \ %%% watch this on PPC!
  273.     inlMk w,  & }  ,str
  274.     align-dp
  275.     method? IF  Mentry  THEN        \ Recompile method entry sequence
  276.     postpone ]  ;
  277.  
  278.  
  279. <" Class
  280.